home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / HARDCORE.FRM < prev    next >
Text File  |  1997-06-14  |  31KB  |  922 lines
  1. VERSION 5.00
  2. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
  3. Begin VB.Form FHardCore 
  4.    AutoRedraw      =   -1  'True
  5.    Caption         =   "Hardcore Samples"
  6.    ClientHeight    =   4800
  7.    ClientLeft      =   3432
  8.    ClientTop       =   3768
  9.    ClientWidth     =   7656
  10.    BeginProperty Font 
  11.       Name            =   "MS Sans Serif"
  12.       Size            =   7.8
  13.       Charset         =   0
  14.       Weight          =   700
  15.       Underline       =   0   'False
  16.       Italic          =   0   'False
  17.       Strikethrough   =   0   'False
  18.    EndProperty
  19.    Icon            =   "HARDCORE.frx":0000
  20.    LinkTopic       =   "Form1"
  21.    PaletteMode     =   1  'UseZOrder
  22.    ScaleHeight     =   4800
  23.    ScaleWidth      =   7656
  24.    WhatsThisHelp   =   -1  'True
  25.    Begin VB.OptionButton optOpen 
  26.       Caption         =   "Picture Form"
  27.       Height          =   264
  28.       Index           =   2
  29.       Left            =   120
  30.       TabIndex        =   10
  31.       Top             =   4380
  32.       Width           =   1560
  33.    End
  34.    Begin VB.OptionButton optOpen 
  35.       Caption         =   "Control"
  36.       Height          =   264
  37.       Index           =   1
  38.       Left            =   120
  39.       TabIndex        =   9
  40.       Top             =   4110
  41.       Width           =   972
  42.    End
  43.    Begin VB.OptionButton optOpen 
  44.       Caption         =   "API"
  45.       Height          =   264
  46.       Index           =   0
  47.       Left            =   120
  48.       TabIndex        =   8
  49.       Top             =   3840
  50.       Value           =   -1  'True
  51.       Width           =   972
  52.    End
  53.    Begin VB.TextBox txtTest 
  54.       Height          =   4272
  55.       Left            =   1464
  56.       MultiLine       =   -1  'True
  57.       ScrollBars      =   3  'Both
  58.       TabIndex        =   7
  59.       Top             =   108
  60.       Width           =   5940
  61.    End
  62.    Begin VB.CommandButton cmdExe 
  63.       Caption         =   "Exe Type"
  64.       Height          =   495
  65.       Left            =   120
  66.       TabIndex        =   6
  67.       Top             =   1920
  68.       Width           =   975
  69.    End
  70.    Begin VB.CommandButton cmdMenus 
  71.       Caption         =   "Menus"
  72.       Height          =   495
  73.       Left            =   120
  74.       TabIndex        =   5
  75.       Top             =   2520
  76.       Width           =   975
  77.    End
  78.    Begin VB.CommandButton cmdOpen 
  79.       Caption         =   "Open File"
  80.       Height          =   495
  81.       Left            =   120
  82.       TabIndex        =   4
  83.       Top             =   3120
  84.       Width           =   975
  85.    End
  86.    Begin VB.PictureBox pbBitmap 
  87.       AutoSize        =   -1  'True
  88.       BorderStyle     =   0  'None
  89.       Height          =   855
  90.       Left            =   1356
  91.       ScaleHeight     =   852
  92.       ScaleWidth      =   888
  93.       TabIndex        =   3
  94.       Top             =   108
  95.       Visible         =   0   'False
  96.       Width           =   885
  97.    End
  98.    Begin VB.CommandButton cmdBlob 
  99.       Caption         =   "Blob"
  100.       Height          =   495
  101.       Left            =   120
  102.       TabIndex        =   2
  103.       Top             =   1320
  104.       Width           =   975
  105.    End
  106.    Begin VB.CommandButton cmdWin32 
  107.       Caption         =   "Win32"
  108.       Height          =   495
  109.       Left            =   120
  110.       TabIndex        =   1
  111.       Top             =   720
  112.       Width           =   975
  113.    End
  114.    Begin VB.CommandButton cmdBits 
  115.       Caption         =   "Bits"
  116.       Height          =   495
  117.       Left            =   120
  118.       TabIndex        =   0
  119.       Top             =   120
  120.       Width           =   975
  121.    End
  122.    Begin MSComDlg.CommonDialog dlgOpenPic 
  123.       Left            =   7776
  124.       Top             =   3924
  125.       _ExtentX        =   699
  126.       _ExtentY        =   699
  127.       _Version        =   327680
  128.       FilterIndex     =   4096
  129.       FontSize        =   1.73997e-39
  130.    End
  131.    Begin VB.Menu mnuFile 
  132.       Caption         =   "&File"
  133.       Begin VB.Menu mnuOpen 
  134.          Caption         =   "&Open..."
  135.       End
  136.       Begin VB.Menu mnuDead 
  137.          Caption         =   "&Dead"
  138.          Enabled         =   0   'False
  139.       End
  140.       Begin VB.Menu mnuGone 
  141.          Caption         =   "&Gone"
  142.          Visible         =   0   'False
  143.       End
  144.       Begin VB.Menu mnuSep1 
  145.          Caption         =   "-"
  146.       End
  147.       Begin VB.Menu mnuExit 
  148.          Caption         =   "E&xit"
  149.       End
  150.    End
  151.    Begin VB.Menu mnuEdit 
  152.       Caption         =   "&Edit"
  153.       Begin VB.Menu mnuCut 
  154.          Caption         =   "Cu&t"
  155.          Shortcut        =   ^X
  156.       End
  157.       Begin VB.Menu mnuPaste 
  158.          Caption         =   "&Paste"
  159.          Shortcut        =   ^V
  160.       End
  161.       Begin VB.Menu mnuView 
  162.          Caption         =   "&View"
  163.          WindowList      =   -1  'True
  164.          Begin VB.Menu mnuSome 
  165.             Caption         =   "&Some"
  166.          End
  167.          Begin VB.Menu mnuAll 
  168.             Caption         =   "&All"
  169.          End
  170.       End
  171.       Begin VB.Menu mnuCheck 
  172.          Caption         =   "&Check"
  173.          Checked         =   -1  'True
  174.       End
  175.    End
  176.    Begin VB.Menu mnuHelp 
  177.       Caption         =   "&Help"
  178.       Begin VB.Menu mnuContents 
  179.          Caption         =   "&Contents"
  180.       End
  181.       Begin VB.Menu mnuAbout 
  182.          Caption         =   "&About..."
  183.       End
  184.    End
  185. End
  186. Attribute VB_Name = "FHardCore"
  187. Attribute VB_GlobalNameSpace = False
  188. Attribute VB_Creatable = False
  189. Attribute VB_PredeclaredId = True
  190. Attribute VB_Exposed = False
  191. Option Explicit
  192.  
  193. Private Type ChunkType
  194.     abData(0 To 255) As Byte
  195. End Type
  196.     
  197. Private Type TestType
  198.     lp As String
  199.     l As Long
  200. End Type
  201.  
  202. Private aEmpty(0) As Variant
  203.  
  204. Private hWndTB As Integer
  205. Private hWndSB As Integer
  206.  
  207. Const SB_HORZ = 0
  208. Const SB_VERT = 1
  209. Const SB_CTL = 2
  210.  
  211. Private Sub Form_Load()
  212.     ChDrive App.Path
  213.     ChDir App.Path
  214.     Show
  215.     Dim color As New CColorPicker
  216.     'color.color = 0
  217.     'color.Load Left + (Width / 2), Top + (Height / 2)
  218. End Sub
  219.  
  220. Private Sub cmdBlob_Click()
  221.     Dim s As String, i As Integer, ab() As Byte, ab2() As Byte
  222.     Dim sMsg As String
  223.     
  224.     sMsg = sMsg & "Type library: " & _
  225.                   IIf(UnicodeTypeLib, "Unicode", "ANSI") & sCrLf
  226.     sMsg = sMsg & "Assign string to byte array and byte string" & sCrLf
  227.     StrToBytes ab, "1234567890"
  228.     s = ab
  229.     sMsg = sMsg & "Byte string as byte array: " & BytesToStr(ab) & sCrLf
  230.     sMsg = sMsg & "Length: " & LenBytes(ab) & sCrLf
  231.     sMsg = sMsg & "Byte string as string: " & StrBToStr(s) & sCrLf
  232.     sMsg = sMsg & "Byte length: " & LenB(s) & sCrLf
  233.     sMsg = sMsg & "String length: " & Len(s) & sCrLfCrLf
  234.  
  235.     sMsg = sMsg & "Read and insert numbers from byte array" & sCrLf
  236.     sMsg = sMsg & "Word (from string) at &H4: &H" & FmtHex(WordFromStrB(s, 4)) & sCrLf
  237.     sMsg = sMsg & "Word (from bytes) at &H4: &H" & FmtHex(BytesToWord(ab, 4)) & sCrLf
  238.     sMsg = sMsg & "DWord at &H4: &H" & FmtHex(BytesToDWord(ab, 4)) & sCrLf
  239.     BytesFromWord &H7372, ab, 4
  240.     sMsg = sMsg & "Insert &H7372 at &H4: " & BytesToStr(ab) & sCrLf
  241.     BytesFromDWord &H65666768, ab, 4
  242.     sMsg = sMsg & "Insert &H65666768 at &H4: " & BytesToStr(ab) & sCrLf
  243.     sMsg = sMsg & "Word at &H4: &H" & FmtHex(BytesToWord(ab, 4)) & sCrLf
  244.     sMsg = sMsg & "DWord at &H4: &H" & FmtHex(BytesToDWord(ab, 4)) & sCrLfCrLf
  245.  
  246.     sMsg = sMsg & "Extract and insert strings on byte array" & sCrLf
  247.     ab = StrToBytesV("1234567890")
  248.     s = ab
  249.     sMsg = sMsg & "Left 3: " & LeftBytes(ab, 3) & sCrLf
  250.     sMsg = sMsg & "Right 3: " & RightBytes(ab, 3) & sCrLf
  251.     sMsg = sMsg & "From &H5: " & MidBytes(ab, 5) & sCrLf
  252.     sMsg = sMsg & "From &H5 length 2: " & MidBytes(ab, 5, 2) & sCrLfCrLf
  253.     InsBytes "ABC", ab, 2
  254.     sMsg = sMsg & "Insert 'ABC' at &h2: " & BytesToStr(ab) & sCrLf
  255. #If 0 Then
  256.     ' This is legal, but textbox doesn't like it
  257.     InsBytes "ABC", ab, 4, 4
  258.     sMsg = sMsg & "Insert 'ABC' at &H4 in field of 4: " & BytesToStr(ab) & sCrLf
  259. #End If
  260.     sMsg = sMsg & "From &H4 length 5 to null: " & MidBytes(ab, 4, 5, True) & sCrLf
  261.     sMsg = sMsg & "From &H4 length 5: " & MidBytes(ab, 4, 5) & sCrLfCrLf
  262.     FillBytes ab, Asc(" "), 5, 4
  263.     sMsg = sMsg & "Insert spaces at &H5 in field of 4: " & BytesToStr(ab) & sCrLfCrLf
  264.  
  265.     ' Test asserts (uncomment for tests)
  266. #If 0 Then
  267.     InsBytes "ABC", ab, 9
  268.     sMsg = sMsg & "Insert 'ABC' at position 9: " & BytesToStr(ab) & sCrLf
  269.     InsBytes "ABC", ab, 8, 4
  270.     sMsg = sMsg & "Insert 'ABC' at position 8 in field of 4: " & BytesToStr(ab) & sCrLf
  271.     FillBytes ab, Asc(" "), 7, 4
  272.     sMsg = sMsg & "Insert spaces at position 7 in field of 4: " & BytesToStr(ab) & sCrLf
  273. #End If
  274.  
  275.     sMsg = sMsg & "Find string in byte array" & sCrLf
  276.     StrToBytes ab, "1234567890"
  277.     s = ab
  278.     ab2 = StrToBytesV("56")
  279.     sMsg = sMsg & "56 at position: " & InStrB(ab, ab2) & sCrLf
  280.     sMsg = sMsg & "56 at position: " & InStrB(s, ab2) & sCrLf
  281.  
  282.     StrToBytes ab, "1234567890"
  283.     s = ab
  284.     sMsg = sMsg & "Hex dump of byte arrays, byte strings, strings" & sCrLf
  285.     sMsg = sMsg & "Dump byte array: " & sCrLf & HexDump(ab, False) & sCrLf
  286.     sMsg = sMsg & "Dump byte string: " & sCrLf & HexDumpB(s, False) & sCrLf
  287.     sMsg = sMsg & "Dump string: " & sCrLf & HexDumpS(s, False) & sCrLfCrLf
  288.     
  289.     sMsg = sMsg & "ANSI characters that don't match Unicode versions" & sCrLf
  290.     For i = 0 To 255
  291.         If AscW(Chr$(i)) <> i Then
  292.             sMsg = sMsg & "ANSI: &H" & FmtHex(i, 2) & sTab
  293.             sMsg = sMsg & "  Unicode: &H" & FmtHex(AscW(Chr$(i)), 4) & sTab
  294.             sMsg = sMsg & "  Character: " & Chr$(i) & sCrLf
  295.         End If
  296.     Next
  297.     sMsg = sMsg & sCrLf
  298.  
  299.     ' Open first file for processing
  300.     Dim sBinFile As String, nBinFile As Integer
  301.     Dim sBin As String, abBin() As Byte
  302.     sBinFile = Dir("*.*")
  303.     nBinFile = FreeFile
  304.     Open sBinFile For Binary Access Read Write Lock Write As #nBinFile
  305.     ReDim abBin(LOF(nBinFile))
  306.     Get #nBinFile, 1, abBin
  307.     sBin = abBin
  308.     sMsg = sMsg & "Open file " & sBinFile & " and process as byte string or byte array" & sCrLf
  309.     sMsg = sMsg & "Dump first 20 byte characters: " & sCrLf
  310.     sMsg = sMsg & HexDumpB(MidB$(sBin, 1, 20)) & sCrLf
  311.     sMsg = sMsg & "Dump first 20 bytes: " & sCrLf
  312.     sMsg = sMsg & HexDump(MidBytes(abBin, 0, 20)) & sCrLf
  313.     abBin = sBin
  314.     Put #nBinFile, 1, abBin
  315.     Close #nBinFile
  316.     
  317.     BugMessage sMsg
  318.     txtTest.Text = sMsg
  319. End Sub
  320.  
  321. Private Sub cmdBits_Click()
  322.     txtTest.Visible = True
  323.     pbBitmap.Visible = False
  324.     Dim dw As Long, w As Integer, r As Single, d As Double
  325.     Dim c As Currency, s As String, i As Integer
  326.     Dim pl As Long, PI As Long, pr As Long, pd As Long
  327.     Dim pc As Long, ps As Long, psz As Long
  328.     Dim sOutput As String
  329.     sOutput = ""
  330.  
  331.     w = &HABCD
  332.     dw = &HFEDCBA98
  333.     'dw = &HFFFF0000
  334.     r = 1.23456789
  335.     d = 9.87654321
  336.     c = 999.99
  337.     s = "Test"
  338.  
  339.     Dim bHi As Byte, bLo As Byte
  340.     Dim wHi As Integer, wLo As Integer
  341.     Dim wPack  As Integer, dwPack  As Long
  342.     Dim wRShift As Integer, wLShift As Integer
  343.     Dim dwRShift As Long, dwLShift As Long
  344.  
  345. #If 1 Then
  346.     bLo = LoByte(w)
  347.     sOutput = sOutput & "Low byte of word (" & Hex$(w) & "): " & Hex$(bLo) & sCrLf
  348.     bHi = HiByte(w)
  349.     sOutput = sOutput & "High byte of word (" & Hex$(w) & "): " & Hex$(bHi) & sCrLf
  350.     wPack = MakeWord(bHi, bLo)
  351.     sOutput = sOutput & "Packed hi/lo bytes of word: " & Hex$(wPack) & sCrLf
  352.     wLo = LoWord(dw)
  353.     sOutput = sOutput & "Low Word of DWord (" & Hex$(dw) & "): " & Hex$(wLo) & sCrLf
  354.     wHi = HiWord(dw)
  355.     sOutput = sOutput & "High Word of DWord (" & Hex$(dw) & "): " & Hex$(wHi) & sCrLf
  356.     dwPack = MakeDWord(wHi, wLo)
  357.     sOutput = sOutput & "Packed hi/lo Word of DWord: " & Hex$(dwPack) & sCrLf
  358. #End If
  359.     
  360. #If 1 Then
  361.     sOutput = sOutput & "Word shifted right" & sCrLf
  362.     For i = 0 To 15
  363.         sOutput = sOutput & Hex$(RShiftWord(w, i)) & "  "
  364.     Next
  365.     sOutput = sOutput & sCrLf
  366.     sOutput = sOutput & "Word shifted left" & sCrLf
  367.     For i = 0 To 15
  368.         sOutput = sOutput & Hex$(LShiftWord(w, i)) & "  "
  369.     Next
  370.     sOutput = sOutput & sCrLf
  371.     sOutput = sOutput & "DWord shifted right C" & sCrLf
  372.     dw = &H70000000
  373.     For i = 0 To 31
  374.         sOutput = sOutput & Hex$(RShiftDWord(dw, i)) & "  "
  375.     Next
  376.     sOutput = sOutput & sCrLf
  377.     sOutput = sOutput & "DWord shifted left C" & sCrLf
  378.     dw = 1
  379.     For i = 0 To 31
  380.         sOutput = sOutput & Hex$(LShiftDWord(dw, i)) & "  "
  381.     Next
  382.     sOutput = sOutput & sCrLf
  383. #End If
  384.     
  385.     w = &H1234
  386.     dw = &H12345678
  387. #If 1 Then
  388.     bLo = LoByte(w)
  389.     sOutput = sOutput & "Low byte of word (" & Hex$(w) & "): " & Hex$(bLo) & sCrLf
  390.     bHi = HiByte(w)
  391.     sOutput = sOutput & "High byte of word (" & Hex$(w) & "): " & Hex$(bHi) & sCrLf
  392.     wPack = MakeWord(bHi, bLo)
  393.     sOutput = sOutput & "Packed hi/lo bytes of word: " & Hex$(wPack) & sCrLf
  394.     wLo = LoWord(dw)
  395.     sOutput = sOutput & "Low Word of DWord (" & Hex$(dw) & "): " & Hex$(wLo) & sCrLf
  396.     wHi = HiWord(dw)
  397.     sOutput = sOutput & "High Word of DWord (" & Hex$(dw) & "): " & Hex$(wHi) & sCrLf
  398.     dwPack = MakeDWord(wHi, wLo)
  399.     sOutput = sOutput & "Packed hi/lo Word of DWord: " & Hex$(dwPack) & sCrLf
  400. #End If
  401.     
  402. #If 1 Then
  403.     sOutput = sOutput & "Word shifted right" & sCrLf
  404.     For i = 0 To 15
  405.         sOutput = sOutput & Hex$(RShiftWord(w, i)) & "  "
  406.     Next
  407.     sOutput = sOutput & sCrLf
  408.     sOutput = sOutput & "Word shifted left" & sCrLf
  409.     For i = 0 To 15
  410.         sOutput = sOutput & Hex$(LShiftWord(w, i)) & "  "
  411.     Next
  412.     sOutput = sOutput & sCrLf
  413.     sOutput = sOutput & "DWord shifted right C" & sCrLf
  414.     dw = &H70000000
  415.     For i = 0 To 31
  416.         sOutput = sOutput & Hex$(RShiftDWord(dw, i)) & "  "
  417.     Next
  418.     sOutput = sOutput & sCrLf
  419.     sOutput = sOutput & "DWord shifted left C" & sCrLf
  420.     dw = 1
  421.     For i = 0 To 31
  422.         sOutput = sOutput & Hex$(LShiftDWord(dw, i)) & "  "
  423.     Next
  424.     sOutput = sOutput & sCrLf
  425. #End If
  426.     
  427.     Dim secStart As Currency, sec As Currency
  428.     ProfileStart secStart
  429.     dw = 50
  430.     For i = 1 To 5000
  431.         dw = RShiftDWord(50, 7)
  432.     Next
  433.     ProfileStop secStart, sec
  434.     sOutput = sOutput & "5000 shifts: " & sec & " seconds" & sCrLf
  435.         
  436.     
  437.     BugMessage sOutput
  438.     txtTest.Text = sOutput
  439.  
  440. End Sub
  441.  
  442. Private Sub cmdExe_Click()
  443.     txtTest.Visible = True
  444.     pbBitmap.Visible = False
  445.  
  446.     Const sFilter = "Executables (*.EXE;*.DLL;*.OCX)|*.exe;*.dll;*.ocx|" & _
  447.                     "EXE Files|*.exe|" & _
  448.                     "DLL Files(*.DLL;*.OCX)|*.dll;*.ocx|" & _
  449.                     "All Files (*.*)|*.*"
  450.     Static iFilterIndex As Long, sFile As String, sInitDir As String
  451.     Dim f As Boolean
  452.     If sInitDir = sEmpty Then sInitDir = WindowsDir
  453.     f = VBGetOpenFileName( _
  454.         filename:=sFile, _
  455.         Flags:=cdlOFNFileMustExist Or cdlOFNHideReadOnly, _
  456.         InitDir:=sInitDir, _
  457.         Filter:=sFilter, _
  458.         FilterIndex:=iFilterIndex)
  459.     sInitDir = GetFileDir(sFile)
  460.     sFile = GetFileBaseExt(sFile)
  461.     txtTest = "EXE type of " & UCase$(sFile) & ": " & ExeTypeStr(sFile)
  462. End Sub
  463.  
  464. Private Sub cmdMenus_Click()
  465.     Dim menu As New CMenuList, item As CMenuItem
  466.     
  467.     txtTest.Visible = True
  468.     pbBitmap.Visible = False
  469.     txtTest = "Some tests of a perfectly good class from the first " & _
  470.               "edition" & vbCrLf & "that didn't make the grade for the " & _
  471.               "the second edition:" & vbCrLf & vbCrLf
  472.     Call menu.Create(Me.hWnd)
  473.     menu.Walk
  474.     Dim s As String
  475.     s = InputBox("Enter menu item to find: ")
  476.     If Not menu.Find(s, item) Then
  477.         MsgBox "Can't find item: " & s
  478.         Exit Sub
  479.     End If
  480.     With item
  481.         s = "Name: " & .Name & sCrLf
  482.         s = s & "Text: " & .Text & sCrLf & "State: "
  483.         s = s & IIf(.Disabled, "Disabled ", sEmpty)
  484.         s = s & IIf(.Checked, "Checked ", sEmpty)
  485.         s = s & IIf(.Grayed, "Grayed ", sEmpty)
  486.         s = s & IIf(.Popup, "Popup ", sEmpty) & sCrLf
  487.         txtTest = txtTest & s
  488.     End With
  489.     Call item.Execute
  490.     menu.Refresh
  491.     Dim f As Boolean
  492.     If menu.Find("Dead", item) Then
  493.         BugMessage item.Disabled
  494.         BugMessage item.Grayed
  495.         item.Text = "&Live"
  496.         BugMessage item.Disabled
  497.         BugMessage item.Grayed
  498.         item.Disabled = False
  499.         BugMessage item.Disabled
  500.         BugMessage item.Grayed
  501.     ElseIf menu.Find("Live", item) Then
  502.         BugMessage item.Disabled
  503.         BugMessage item.Grayed
  504.         item.Text = "&Dead"
  505.         BugMessage item.Disabled
  506.         BugMessage item.Grayed
  507.         item.Disabled = True
  508.         BugMessage item.Disabled
  509.         BugMessage item.Grayed
  510.     End If
  511.  
  512.     Dim SysMenu As New CMenuList
  513.     f = SysMenu.Create(Me.hWnd, True)
  514.     SysMenu.Walk
  515.     If WindowState = vbMaximized Then
  516.         f = SysMenu.Find("Restore", item)
  517.     Else
  518.         f = SysMenu.Find("Maximize", item)
  519.     End If
  520.     'f = SysMenu.Find("Switch To", item)
  521.     f = item.Execute
  522.         
  523. End Sub
  524.  
  525. Private Sub cmdOpen_Click()
  526.     txtTest.Visible = False
  527.     pbBitmap.Visible = True
  528.     
  529.     Const sFilters = "All Picture Files|*.bmp;*.dib;*.ico;*.wmf;*.cur|" & _
  530.                      "Bitmaps (*.BMP;*.DIB)|*.bmp;*.dib|" & _
  531.                      "Metafiles (*.WMF)|*.wmf|" & _
  532.                      "Icons (*.ICO)|*.ico|" & _
  533.                      "Cursors (*.CUR;*.ICO)|*.cur;*.ico|" & _
  534.                      "All Files (*.*)|*.*"
  535.     Select Case GetOption(optOpen)
  536.     Case 0
  537.         Dim sFilter As String
  538.         sFilter = sFilters
  539.         Dim sFile As String, f As Boolean
  540.         f = VBGetOpenFileName( _
  541.             filename:=sFile, _
  542.             InitDir:=WindowsDir, _
  543.             Flags:=cdlOFNFileMustExist Or cdlOFNHideReadOnly, _
  544.             Filter:=sFilter) ' *.bmp;*.dib;*.ico;*.wmf;*.cur
  545.         If f And sFile <> sEmpty Then
  546.             Set pbBitmap.Picture = LoadPicture(sFile)
  547.         End If
  548.     Case 1
  549.         With dlgOpenPic
  550.             .InitDir = WindowsDir
  551.             .Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
  552.             .Filter = sFilters ' *.bmp;*.dib;*.ico;*.wmf;*.cur
  553.             .ShowOpen
  554.             If .filename <> sEmpty Then
  555.                 Set pbBitmap.Picture = LoadPicture(.filename)
  556.             End If
  557.         End With
  558.     Case 2
  559.         Dim opfile As New COpenPictureFile
  560.         With opfile
  561.             .InitDir = WindowsDir
  562.             .Load Left + (Width / 4), Top + (Height / 4)
  563.             If .filename <> sEmpty Then
  564.                 pbBitmap.Picture = LoadPicture(.filename)
  565.             End If
  566.         End With
  567.     End Select
  568.  
  569. End Sub
  570.  
  571.  
  572.  
  573. Private Sub cmdWin32_Click()
  574.  
  575.     Dim i As Integer, s As String, sVal As String
  576.     Dim sName As String, sFullName As String
  577.     Dim c As Long, f As Boolean
  578.     Dim iDir As Long, iBase As Long, iExt As Long
  579.     
  580.     txtTest.Visible = True
  581.     pbBitmap.Visible = False
  582.     sName = GetTempDir()
  583.     
  584.     ' Test ExistFile
  585.     s = "Test ExistFile" & sCrLf & sCrLf
  586.     sName = Environ$("COMSPEC")
  587.     s = s & "File " & sName & " exists: " & ExistFile(sName) & sCrLf
  588.     sName = "nosuch.txt"
  589.     s = s & "File " & sName & " exists: " & ExistFile(sName) & sCrLf
  590.     
  591.     ' Test GetFullPathName
  592.     s = s & sCrLf & "Test GetFullPathName" & sCrLf & sCrLf
  593.     Dim sBase As String, pBase As Long
  594.     sFullName = String$(cMaxPath, 0)
  595.     c = GetFullPathName(sName, cMaxPath, sFullName, pBase)
  596.     sFullName = Left$(sFullName, c)
  597.     If c Then s = s & "Full name: " & sFullName & sCrLf
  598.     ' Can't use pBase because pointer is to temporary Unicode string
  599.  
  600. #If 1 Then
  601.     s = s & sCrLf & "Test GetFullPath with invalid argument" & sCrLf & sCrLf
  602.     sFullName = GetFullPath("", iBase, iExt, iDir)
  603.     If sFullName = sEmpty Then
  604.         s = s & "Failed: Error " & Err.LastDllError & sCrLf
  605.     Else
  606.         s = s & "File: " & sFullName & sCrLf
  607.     End If
  608. #End If
  609.  
  610.     s = s & sCrLf & "Test GetFullPath with all arguments" & sCrLf & sCrLf
  611.     sFullName = GetFullPath(sName, iBase, iExt, iDir)
  612.     If sFullName <> sEmpty Then
  613.         s = s & "Relative file: " & sName & sCrLf
  614.         s = s & "Full name: " & sFullName & sCrLf
  615.         s = s & "File: " & Mid$(sFullName, iBase) & sCrLf
  616.         s = s & "Extension: " & Mid$(sFullName, iExt) & sCrLf
  617.         s = s & "Base name: " & Mid$(sFullName, iBase, _
  618.                                      iExt - iBase) & sCrLf
  619.         s = s & "Drive: " & Left$(sFullName, iDir - 1) & sCrLf
  620.         s = s & "Directory: " & Mid$(sFullName, iDir, _
  621.                                      iBase - iDir) & sCrLf
  622.         s = s & "Path: " & Left$(sFullName, iBase - 1) & sCrLf
  623.     Else
  624.         s = s & "Invalid name: " & sName
  625.     End If
  626.         
  627.     sFullName = GetFullPath(sName, iBase, iExt, iDir)
  628.     sFullName = GetFullPath(sName, iBase, iExt)
  629.     sFullName = GetFullPath(sName, iBase)
  630.     sFullName = GetFullPath(sName)
  631.     sFullName = GetFullPath(sName, , iExt)
  632.     sFullName = GetFullPath(sName, , iExt, iDir)
  633.     sFullName = GetFullPath(sName, , , iDir)
  634.     sFullName = GetFullPath(sName, iBase, , iDir)
  635.     
  636.     Dim sPart As String
  637.     sName = "Hardcore.frm"
  638.     sPart = GetFullPath(sName)      ' C:\Hardcore\Hardcore.frm
  639.     sPart = GetFileBase(sName)      ' Hardcore
  640.     sPart = GetFileBaseExt(sName)   ' Hardcore.frm
  641.     sPart = GetFileExt(sName)       ' .frm
  642.     sPart = GetFileDir(sName)       ' C:\Hardcore\
  643.  
  644.  
  645.     s = s & sCrLf & "Test GetFullPath with some arguments" & sCrLf & sCrLf
  646.     sFullName = GetFullPath(sName, iBase, iExt)
  647.     If sFullName <> sEmpty Then
  648.         s = s & "Relative file: " & sName & sCrLf
  649.         s = s & "Full name: " & sFullName & sCrLf
  650.         s = s & "File: " & Mid$(sFullName, iBase) & sCrLf
  651.         s = s & "Extension: " & Mid$(sFullName, iExt) & sCrLf
  652.         s = s & "Base name: " & Mid$(sFullName, iBase, _
  653.                                      iExt - iBase) & sCrLf
  654.         s = s & "Path: " & Left$(sFullName, iBase - 1) & sCrLf
  655.     Else
  656.         s = s & "Invalid name: " & sName
  657.     End If
  658.     
  659.     s = s & sCrLf & "Test GetFullPath with no optional arguments" & sCrLf & sCrLf
  660.     sFullName = GetFullPath(sName)
  661.     If sFullName <> sEmpty Then
  662.         s = s & "Relative file: " & sName & sCrLf
  663.         s = s & "Full name: " & sFullName & sCrLf
  664.     Else
  665.         s = s & "Invalid name: " & sName
  666.     End If
  667.     
  668.     ' Test SearchPath
  669.     s = s & sCrLf & "Test SearchPath" & sCrLf & sCrLf
  670.     sName = "vb.hlp"
  671.     sFullName = String$(cMaxPath, 0)
  672.     i = SearchPath(vbNullString, sName, vbNullString, cMaxPath, sFullName, pBase)
  673.     sFullName = Left$(sFullName, i)
  674.     If i Then
  675.         s = s & "File " & sName & " found in: " & sFullName & sCrLf
  676.         ' Can't use pBase because pointer is to temporary Unicode string
  677.     Else
  678.         s = s & "File " & sName & " not found" & sCrLf
  679.     End If
  680.     
  681.     s = s & sCrLf & "Test SearchDirs" & sCrLf & sCrLf
  682.          
  683.          
  684.     sFullName = SearchDirs("calc", ".exe", , iBase, iExt, iDir)
  685.     sFullName = SearchDirs("calc.exe", , , iBase, iExt)
  686.     sFullName = SearchDirs("calc", ".exe", Environ("PATH"), iBase)
  687.     sFullName = SearchDirs("calc.exe")
  688.        
  689.     sName = "vbe.dll"
  690.     sFullName = SearchDirs(sName, sEmpty, sEmpty, iBase, iExt, iDir)
  691.     If sFullName <> sEmpty Then
  692.         s = s & "Found file " & sName
  693.         s = s & " in " & sFullName & sCrLf
  694.         s = s & "File: " & Mid$(sFullName, iBase) & sCrLf
  695.         s = s & "Extension: " & Mid$(sFullName, iExt) & sCrLf
  696.         s = s & "Base name: " & Mid$(sFullName, iBase, _
  697.                                      iExt - iBase) & sCrLf
  698.         s = s & "Drive: " & Left$(sFullName, iDir - 1) & sCrLf
  699.         s = s & "Directory: " & Mid$(sFullName, iDir, _
  700.                                      iBase - iDir) & sCrLf
  701.         s = s & "Path: " & Left$(sFullName, iBase - 1) & sCrLf
  702.     Else
  703.         s = s & "File " & sName & " not found" & sCrLf
  704.     End If
  705.  
  706.     sName = "hardcore.frm"
  707.     sFullName = SearchDirs(sName)
  708.     If sFullName <> sEmpty Then
  709.         s = s & "File " & sName & " found in: " & sFullName & sCrLf
  710.     Else
  711.         s = s & "File " & sName & " not found" & sCrLf
  712.     End If
  713.     
  714.     sName = "calc.exe"
  715.     sFullName = SearchDirs(sName)
  716.     If sFullName <> sEmpty Then
  717.         s = s & "File " & sName & " found in: " & sFullName & sCrLf
  718.     Else
  719.         s = s & "File " & sName & " not found" & sCrLf
  720.     End If
  721.     
  722.     sName = "gdi32.dll"
  723.     sFullName = SearchDirs(sName)
  724.     If sFullName <> sEmpty Then
  725.         s = s & "File " & sName & " found in: " & sFullName & sCrLf
  726.     Else
  727.         s = s & "File " & sName & " not found" & sCrLf
  728.     End If
  729.  
  730.     sName = "find.exe"
  731.     sFullName = SearchDirs(sName)
  732.     If sFullName <> sEmpty Then
  733.         s = s & "File " & sName & " found in: " & sFullName & sCrLf
  734.     Else
  735.         s = s & "File " & sName & " not found" & sCrLf
  736.     End If
  737.  
  738.     sFullName = SearchDirs("WINDOWS.H", , Environ("INCLUDE"))
  739.     sName = "WINDOWS.H"
  740.     sFullName = SearchDirs(sName, , Environ("INCLUDE"))
  741.     If sFullName <> sEmpty Then
  742.         s = s & "File found in: " & sFullName & sCrLf
  743.     Else
  744.         s = s & "File not found" & sCrLf
  745.     End If
  746.     
  747.     sFullName = SearchDirs("DEBUG.BAS", , ".")
  748.     sName = "DEBUG.BAS"
  749.     sFullName = SearchDirs(sName, , ".")
  750.     If sFullName <> sEmpty Then
  751.         s = s & "File " & sName & " found in: " & sFullName & sCrLf
  752.     Else
  753.         s = s & "File " & sName & " not found" & sCrLf
  754.     End If
  755.           
  756.     sFullName = GetFullPath("DEBUG.BAS")
  757.     
  758.     sName = "EDIT"
  759.     Dim asExts(1 To 4) As String
  760.     asExts(1) = ".EXE": asExts(2) = ".COM"
  761.     asExts(3) = ".BAT": asExts(4) = ".PIF"
  762.     For i = 1 To 4
  763.         sFullName = SearchDirs(sName, asExts(i))
  764.         If sFullName <> sEmpty Then Exit For
  765.     Next
  766.     If sFullName <> sEmpty Then
  767.         s = s & "File found in: " & sFullName & sCrLf
  768.     Else
  769.         s = s & "File " & sName & " not found" & sCrLf
  770.     End If
  771.     
  772.     ' Test GetDiskFreeSpace and GetDriveType
  773.     s = s & sCrLf & "Test GetDiskFreeSpace and GetDriveType" & sCrLf & sCrLf
  774.     Dim iSectors As Long, iBytes As Long
  775.     Dim iFree As Long, iTotal As Long
  776.     Dim rFree As Double, rTotal As Double
  777.     sName = "%:\"
  778.     Dim sTab As String
  779.     For i = 1 To 26
  780.         sVal = Chr$(i + Asc("A") - 1)
  781.         Mid$(sName, 1, 1) = sVal
  782.  
  783.         c = GetDriveType(sName)
  784.         s = s & "Disk " & sVal & " type: "
  785.         s = s & Choose(c + 1, "Unknown", "Invalid", "Floppy ", _
  786.                               "Hard   ", "Network", "CD-ROM ", "RAM    ")
  787.  
  788.         f = GetDiskFreeSpace(sName, iSectors, iBytes, iFree, iTotal)
  789.         rFree = iSectors * iBytes * CDbl(iFree)
  790.         rTotal = iSectors * iBytes * CDbl(iTotal)
  791.         If f Then
  792.             s = s & " with " & Format$(rFree, "#,###,###,##0")
  793.             s = s & " free from " & Format$(rTotal, "#,###,###,##0") & sCrLf
  794.         Else
  795.             s = s & sCrLf
  796.         End If
  797.     Next
  798.     ' txtTest.Text = s
  799.  
  800.     ' Test GetTempPath and GetTempFileName
  801.     s = s & sCrLf & "Test GetTempPath and GetTempFileName" & sCrLf & sCrLf
  802.     c = cMaxPath
  803.     sFullName = String$(c, 0)
  804.     c = GetTempPath(c, sFullName)
  805.     sFullName = Left$(sFullName, c)
  806.     s = s & "Temp Path: " & sFullName & sCrLf
  807.     sFullName = String$(cMaxPath, 0)
  808.     Call GetTempFileName(".", "HC", 0, sFullName)
  809.     sFullName = Left$(sFullName, InStr(sFullName, vbNullChar) - 1)
  810.     s = s & "Temp File: " & sFullName & sCrLf
  811.     
  812.     s = s & sCrLf & "Test GetTempFile and GetTempDir" & sCrLf & sCrLf
  813.     ' Get temp file for current directory
  814.     sFullName = GetTempFile("VB", ".")
  815.     s = s & "Temp file in current directory: " & sFullName & sCrLf
  816.     ' Get temp file for TEMP directory
  817.     sFullName = GetTempFile("VB", GetTempDir)
  818.     ' Get temp file for TEMP directory default
  819.     sFullName = GetTempFile("VB")
  820.     ' Get temp file for TEMP directory with no prefix
  821.     sFullName = GetTempFile
  822.     s = s & "Temp file in TEMP directory: " & sFullName & sCrLf
  823.     sFullName = GetTempFile
  824.     s = s & "Temp file with defaults (no prefix, TEMP directory): " & sFullName & sCrLf
  825.     sFullName = GetTempFile("HC")
  826.     s = s & "Temp file with path default (TEMP directory): " & sFullName & sCrLf
  827.     sFullName = GetTempFile(, ".")
  828.     s = s & "Temp file with prefix default (no prefix directory): " & sFullName & sCrLf
  829.  
  830.    ' Test GetLogicalDrives
  831.     s = s & sCrLf & "Test GetLogicalDrives" & sCrLf & sCrLf
  832.     sVal = VBGetLogicalDrives()
  833.     s = s & "Drives    ABCDEFGHIJKLMNOPQRSTUVWXYZ" & sCrLf
  834.     s = s & "Drives    " & sVal & sCrLf
  835.  
  836.     On Error Resume Next
  837. '    Kill "~HC*.tmp"
  838. '    Kill "HC*.tmp"
  839.     On Error GoTo 0
  840.     
  841.     BugMessage s
  842.     txtTest.Text = s
  843.     
  844. End Sub
  845.  
  846. Sub ShowStr(s As String)
  847.     Debug.Print s
  848. End Sub
  849.  
  850. Sub ShowBytes(ab() As Byte)
  851.     Dim i As Integer, iMin As Integer, iMax As Integer, s As String
  852.     iMin = LBound(ab): iMax = UBound(ab)
  853.     For i = iMin To iMax
  854.         s = s & Chr$(ab(i))
  855.     Next
  856.     Debug.Print s
  857. End Sub
  858.  
  859. Private Sub mnuCheck_Click()
  860.     mnuCheck.Checked = Not mnuCheck.Checked
  861. End Sub
  862.  
  863. Private Sub mnuDead_Click()
  864.     MsgBox mnuDead.Caption
  865. End Sub
  866.  
  867. Private Sub mnuExit_Click()
  868.     Unload Me
  869. End Sub
  870.  
  871. Private Sub mnuOpen_Click()
  872.     MsgBox mnuOpen.Caption
  873. End Sub
  874.  
  875. Private Sub mnuGone_Click()
  876.     MsgBox mnuGone.Caption
  877. End Sub
  878.  
  879. Private Sub mnuCut_Click()
  880.     MsgBox mnuCut.Caption
  881. End Sub
  882.  
  883. Private Sub mnuPaste_Click()
  884.     MsgBox mnuPaste.Caption
  885. End Sub
  886.  
  887. Private Sub mnuSome_Click()
  888.     MsgBox mnuSome.Caption
  889. End Sub
  890.  
  891. Private Sub mnuAll_Click()
  892.     MsgBox mnuAll.Caption
  893. End Sub
  894.  
  895. Private Sub mnuContents_Click()
  896.     MsgBox mnuContents.Caption
  897. End Sub
  898.  
  899. Private Sub mnuAbout_Click()
  900.     MsgBox mnuAbout.Caption
  901. End Sub
  902.  
  903. Private Sub cmdExit_Click()
  904.     Unload Me
  905. End Sub
  906.  
  907. Function WordFromStrB(sBuf As String, iOffset As Long) As Integer
  908.     BugAssert (iOffset + 2) <= LenB(sBuf) - 1
  909.     Dim dw As Long
  910.     dw = AscB(MidB$(sBuf, iOffset + 2, 1)) * 256&
  911.     dw = dw + AscB(MidB$(sBuf, iOffset + 1, 1))
  912.     If dw And &H8000& Then
  913.         WordFromStrB = &H8000 Or (dw And &H7FFF&)
  914.     Else
  915.         WordFromStrB = dw And &HFFFF&
  916.     End If
  917. End Function
  918. '
  919. Private Sub pick_Picked(color As stdole.OLE_COLOR)
  920.     BackColor = color
  921. End Sub
  922.